home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 22 / Cream of the Crop 22.iso / program / tdk_v120.zip / ANSIUNIT.PAS < prev    next >
Pascal/Delphi Source File  |  1996-07-15  |  8KB  |  357 lines
  1. {
  2.  ▀▀▀▀▀▀▀▀  ▀▀▀▀▀▀    ▀▀   ▀▀
  3.    ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  4.   ▀▀     ▀▀   ▀▀▀  ▀▀▀▀▀  The DoorKit!
  5.  ▀▀     ▀▀   ▀▀   ▀▀  ▀▀
  6. ▀▀     ▀▀▀▀▀▀    ▀▀    ▀▀
  7. The BBS Door Development Kit By The People - For The People!
  8.  
  9.  
  10.    Feel free to modify or optimize this code at will. All I ask is that if
  11.    find a better way to do things (and you will), please send me a copy of
  12.    your modifications. Thanks in advance!....Larry L. Athey....}
  13.  
  14. UNIT ANSIUNIT;
  15.  
  16. INTERFACE
  17.  
  18. USES CRT, DOS;
  19.  
  20. PROCEDURE AnsiWrite(Ch : CHAR);
  21. PROCEDURE AnsiWriteLn(S : STRING);
  22.  
  23. VAR
  24.   My_WhereX : BYTE;
  25.   My_WhereY : BYTE; {These are used in the place of WhereX and WhereY
  26.                      because this unit uses direct screen writes for
  27.                      displaying ANSI files. If you want to know what
  28.                      your cursor position is, reference these instead.}
  29.  
  30. IMPLEMENTATION
  31.  
  32. CONST
  33.   RecANSI : BOOLEAN = FALSE;
  34.  
  35. VAR
  36.   Escape        : BYTE;
  37.   Saved_X       : BYTE;
  38.   Saved_Y       : BYTE;
  39.   Control_Code  : STRING;
  40.   Screen_Bottom : WORD;
  41.   ThisSeg       : WORD;
  42.  
  43. PROCEDURE My_GotoXY(X,Y : BYTE);
  44. BEGIN
  45.   My_WhereX := X;
  46.   My_WhereY := Y;
  47. END;
  48.  
  49. PROCEDURE TABULATE;
  50. VAR
  51.   X : INTEGER;
  52. BEGIN
  53.   X := MY_WhereX;
  54.   IF X < 80 THEN
  55.   REPEAT
  56.     INC(X);
  57.   UNTIL (X MOD 8) = 0;
  58.   IF X = 80 THEN X := 1;
  59.   My_GotoXY(X,My_WhereY);
  60.   IF X = 1 THEN INC(My_WhereY);
  61. END;
  62.  
  63. PROCEDURE BACKSPACE;
  64. VAR
  65.   X : INTEGER;
  66. BEGIN
  67.   IF MY_WhereX > 1 THEN
  68.   BEGIN
  69.     DEC(My_WhereX);
  70.     WRITE(' ');
  71.     DEC(My_WhereX);
  72.   END ELSE IF My_WhereY > 1 THEN BEGIN
  73.     My_GotoXY(80,My_WhereY - 1);
  74.     WRITE(' ');
  75.     My_GotoXY(80,My_WhereY - 1);
  76.   END;
  77. END;
  78.  
  79. PROCEDURE WRITE(Ch : CHAR);
  80. BEGIN
  81.   CASE Ch OF
  82.    ^G : BEGIN
  83.           SOUND(2000);
  84.           DELAY(75);
  85.           NOSOUND;
  86.         END;
  87.    ^H : Backspace;
  88.    ^I : Tabulate;
  89.    ^J : BEGIN
  90.           TEXTBACKGROUND(0);
  91.           INC(My_WhereY);
  92.         END;
  93.    ^K : My_GotoXY(1,1);
  94.    ^L : BEGIN
  95.           TEXTBACKGROUND(0);
  96.           My_GotoXY(1,1);
  97.         END;
  98.    ^M : BEGIN
  99.           TEXTBACKGROUND(0);
  100.           My_WhereX := 1;
  101.         END;
  102.     ELSE BEGIN
  103.       Mem[ThisSeg : (160 * (My_WhereY - 1)) + (2 * (My_WhereX - 1))] := ORD(Ch);
  104.       Mem[ThisSeg : (160 * (My_WhereY - 1)) + (2 * (My_WhereX - 1)) + 1] := TextAttr;
  105.       INC(My_WhereX);
  106.       IF My_whereX = 81 THEN BEGIN
  107.         My_WhereX := 1;
  108.         INC(My_WhereY);
  109.       END;
  110.     END;
  111.   END;
  112.   IF (MY_WhereY > Screen_Bottom) THEN Screen_Bottom := My_WhereY;
  113. END;
  114.  
  115. FUNCTION GetNumber(VAR Line : STRING) : INTEGER;
  116. VAR
  117.   I,J,K : INTEGER;
  118.   Temp0,
  119.   Temp1 : STRING;
  120. BEGIN
  121.   Temp0 := Line;
  122.   VAL(Temp0,I,J);
  123.   IF J = 0 THEN temp0 := '' ELSE BEGIN
  124.     Temp1 := COPY(Temp0,1,J-1);
  125.     DELETE(Temp0,1,J);
  126.     VAL(Temp1,I,J);
  127.   END;
  128.   Line := Temp0;
  129.   GetNumber := I;
  130. END;
  131.  
  132. PROCEDURE LoseIt;
  133. BEGIN
  134.   Escape := 0;
  135.   Control_Code := '';
  136.   RecANSI := FALSE;
  137. END;
  138.  
  139. PROCEDURE Ansi_Cursor_Move;
  140. VAR
  141.   X,Y : INTEGER;
  142. BEGIN
  143.   Y := GetNumber(Control_Code);
  144.   IF Y = 0 THEN Y := 1;
  145.   X := GetNumber(Control_Code);
  146.   IF X = 0 THEN X := 1;
  147.   IF Y > 25 THEN Y := 25;
  148.   IF X > 80 THEN X := 80;
  149.   My_GotoXY(X,Y);
  150.   LoseIt;
  151. END;
  152.  
  153. PROCEDURE Ansi_Cursor_Up;
  154. VAR
  155.   Y,New_Y,OffSet : INTEGER;
  156. BEGIN
  157.   Offset := GetNumber(Control_Code);
  158.   IF Offset = 0 THEN Offset := 1;
  159.   Y := My_WhereY;
  160.   IF (Y - Offset) < 1 THEN New_Y := 1 ELSE New_Y := Y - Offset;
  161.   My_GotoXY(My_WhereX,New_Y);
  162.   LoseIt;
  163. END;
  164.  
  165. PROCEDURE Ansi_Cursor_Down;
  166. VAR
  167.   Y,New_Y,Offset : INTEGER;
  168. BEGIN
  169.   Offset := GetNumber(Control_Code);
  170.   IF Offset = 0 THEN Offset := 1;
  171.   Y := My_WhereY;
  172.   IF (Y + Offset) > 25 THEN New_Y := 25 ELSE New_Y := Y + Offset;
  173.   My_GotoXY(My_WhereX,New_Y);
  174.   loseit;
  175. END;
  176.  
  177. PROCEDURE Ansi_Cursor_Left;
  178. VAR
  179.   x,new_x,offset : INTEGER;
  180. BEGIN
  181.   Offset := GetNumber(Control_Code);
  182.   IF Offset = 0 THEN Offset := 1;
  183.   X := My_WhereX;
  184.   IF (X - Offset) < 1 THEN New_X := 1 ELSE New_X := X - Offset;
  185.   My_GotoXY(New_X,My_WhereY);
  186.   LoseIt;
  187. END;
  188.  
  189. PROCEDURE Ansi_Cursor_Right;
  190. VAR
  191.   X,New_X,Offset : INTEGER;
  192. BEGIN
  193.   Offset := GetNumber(Control_Code);
  194.   IF Offset = 0 THEN Offset := 1;
  195.   X := My_WhereX;
  196.   IF (X + Offset) > 80 THEN New_X := 1 ELSE New_X := X + Offset;
  197.   My_GotoXY(New_X,My_WhereY);
  198.   LoseIt;
  199. END;
  200.  
  201. PROCEDURE Ansi_Clear_Screen;
  202. BEGIN
  203.   CLRSCR;
  204.   My_GotoXY(1,1);
  205.   LoseIt;
  206. END;
  207.  
  208. PROCEDURE Ansi_Clear_EoLine;
  209. VAR
  210.   Temp : BYTE;
  211. BEGIN
  212.   Temp := My_WhereX;
  213.   REPEAT
  214.     Mem[ThisSeg : (160 * (My_WhereY - 1)) + (2 * (Temp - 1))] := ORD(' ');
  215.     Mem[ThisSeg : (160 * (My_WhereY - 1)) + (2 * (Temp - 1)) + 1] := TextAttr;
  216.     INC(Temp)
  217.   UNTIL Temp > 80;
  218.   LoseIt;
  219. END;
  220.  
  221. PROCEDURE Reverse_Video;
  222. VAR
  223.   TempAttr, tBlink, TempAttrLO, TempAttrHI : BYTE;
  224. BEGIN
  225.   LOWVIDEO;
  226.   TempAttrLO := (TextAttr AND $7);
  227.   TempAttrHI := (TextAttr AND $70);
  228.   tBlink     := (Textattr AND $80);
  229.   TempAttrLO := TempattrLO * 16;
  230.   TempAttrHI := TempAttrHI DIV 16;
  231.   TextAttr   := TempAttrHI + TempAttrLO + tBlink;
  232. END;
  233.  
  234. PROCEDURE Ansi_Set_Colors;
  235. VAR
  236.   Temp0,Color_Code : INTEGER;
  237. BEGIN
  238.   IF LENGTH(Control_Code) = 0 THEN Control_Code := '0';
  239.   WHILE (LENGTH(Control_Code) > 0) DO BEGIN
  240.     Color_Code := GetNumber(Control_Code);
  241.     CASE Color_code OF
  242.       0  :  BEGIN
  243.               LOWVIDEO;
  244.               TEXTCOLOR(7);
  245.               TEXTBACKGROUND(0);
  246.             END;
  247.       1  : HIGHVIDEO;
  248.       5  : TextAttr := (TextAttr OR $80);
  249.       7  : Reverse_Video;
  250.       30 : TextAttr := (TextAttr AND $F8) + 0;
  251.       31 : TextAttr := (TextAttr AND $f8) + 4;
  252.       32 : TextAttr := (TextAttr AND $f8) + 2;
  253.       33 : TextAttr := (TextAttr AND $f8) + 6;
  254.       34 : TextAttr := (TextAttr AND $f8) + 1;
  255.       35 : TextAttr := (TextAttr AND $f8) + 5;
  256.       36 : TextAttr := (TextAttr AND $f8) + 3;
  257.       37 : TextAttr := (TextAttr AND $f8) + 7;
  258.       40 : TEXTBACKGROUND(0);
  259.       41 : TEXTBACKGROUND(4);
  260.       42 : TEXTBACKGROUND(2);
  261.       43 : TEXTBACKGROUND(14);
  262.       44 : TEXTBACKGROUND(1);
  263.       45 : TEXTBACKGROUND(5);
  264.       46 : TEXTBACKGROUND(3);
  265.       47 : TEXTBACKGROUND(15);
  266.     END;
  267.   END;
  268.   LoseIt;
  269. END;
  270.  
  271. PROCEDURE Ansi_Save_Cur_pos;
  272. BEGIN
  273.   Saved_X := My_WhereX;
  274.   Saved_Y := My_WhereY;
  275.   LoseIt;
  276. END;
  277.  
  278. PROCEDURE Ansi_Restore_Cur_Pos;
  279. BEGIN
  280.   My_GotoXY(Saved_X,Saved_Y);
  281.   LoseIt;
  282. END;
  283.  
  284. PROCEDURE Ansi_Check_Code(Ch : CHAR);
  285. BEGIN
  286.   CASE Ch OF
  287.     '0'..'9',
  288.     ';' : Control_Code := Control_Code + Ch;
  289.     'H',
  290.     'f' : Ansi_Cursor_Move;
  291.     'A' : Ansi_Cursor_Up;
  292.     'B' : Ansi_Cursor_Down;
  293.     'C' : Ansi_Cursor_Right;
  294.     'D' : Ansi_Cursor_Left;
  295.     'J' : Ansi_Clear_Screen;
  296.     'K' : Ansi_Clear_EoLine;
  297.     'm' : Ansi_Set_Colors;
  298.     's' : Ansi_Save_Cur_Pos;
  299.     'u' : Ansi_Restore_Cur_pos;
  300.     '?' : ;
  301.     ELSE LoseIt;
  302.   END;
  303. END;
  304.  
  305. PROCEDURE AnsiWrite(Ch : CHAR);
  306. VAR
  307.   Temp0 : INTEGER;
  308. BEGIN
  309.   IF Escape > 0 THEN BEGIN
  310.     CASE Escape OF
  311.       1 : BEGIN
  312.             IF Ch = '[' THEN BEGIN
  313.             Escape := 2;
  314.             Control_Code := '';
  315.             END ELSE escape := 0;
  316.           END;
  317.       2 : Ansi_Check_Code(Ch);
  318.       ELSE BEGIN
  319.         Escape := 0;
  320.         Control_Code := '';
  321.         RecANSI := FALSE;
  322.       END;
  323.     END;
  324.   END ELSE BEGIN
  325.     CASE Ch OF
  326.       #27 : Escape := 1;
  327.       #9  : BEGIN
  328.               Temp0 := My_WhereX;
  329.               Temp0 := Temp0 DIV 8;
  330.               Temp0 := Temp0 + 1;
  331.               Temp0 := Temp0 * 8;
  332.               My_GotoXY(Temp0,My_WhereY);
  333.             END;
  334.       ELSE BEGIN
  335.         IF ((My_WhereX = 80) AND (My_WhereY = 25)) THEN BEGIN
  336.           WindMax := (80 + (24 * 256));
  337.           WRITE(Ch);
  338.           WindMax := (79 + (24 * 256));
  339.         END ELSE WRITE(Ch);
  340.         Escape := 0;
  341.       END;
  342.     END;
  343.   END;
  344.   RecANSI := (Escape <> 0);
  345. END;
  346.  
  347. PROCEDURE AnsiWriteLn(S : STRING);
  348. VAR
  349.   I : BYTE;
  350. BEGIN
  351.   FOR I := 1 TO LENGTH(S) DO AnsiWrite(S[I]);
  352. END;
  353.  
  354. BEGIN
  355.   ThisSeg := Segb800;
  356. END.
  357.